home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / redisp.lisp < prev    next >
Text File  |  1993-07-17  |  49KB  |  1,082 lines
  1. ;;; -*- Mode:LISP; Package:(BOXER GLOBAL 1000); Base: 8.; Fonts: cptfont -*-
  2.  
  3. ;;; (C) Copyright 1985 Massachusetts Institute of Technology
  4. ;;;
  5. ;;; Permission to use, copy, modify, distribute, and sell this software
  6. ;;; and its documentation for any purpose is hereby granted without fee,
  7. ;;; provided that the above copyright notice appear in all copies and that
  8. ;;; both that copyright notice and this permission notice appear in
  9. ;;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;;; advertising or publicity pertaining to distribution of the software
  11. ;;; without specific, written prior permission.  M.I.T. makes no
  12. ;;; representations about the suitability of this software for any
  13. ;;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;;
  15.  
  16. ;;;This file contains all of the high level code that the redisplay uses
  17.  
  18.  
  19. (DEFWHOPPER (SCREEN-BOX :REDISPLAY-PASS-1) (&REST ARGS-TO-METHOD)
  20.   (LET ((*COMPLETE-REDISPLAY-IN-PROGRESS?* (OR *COMPLETE-REDISPLAY-IN-PROGRESS?*
  21.                            FORCE-REDISPLAY-INFS?)))
  22.    ;(IF *COMPLETE-REDISPLAY-IN-PROGRESS?* (ERASE-SCREEN-OBJ SELF))
  23.     (LEXPR-CONTINUE-WHOPPER ARGS-TO-METHOD)))
  24.  
  25. (DEFWHOPPER (SCREEN-BOX :REDISPLAY-PASS-2) (&REST ARGS-TO-METHOD)
  26.   (LET ((*COMPLETE-REDISPLAY-IN-PROGRESS?* (OR *COMPLETE-REDISPLAY-IN-PROGRESS?*
  27.                            FORCE-REDISPLAY-INFS?)))
  28.     (LEXPR-CONTINUE-WHOPPER ARGS-TO-METHOD)))
  29.  
  30.  
  31. ;;; Set things up so that the actual redisplay methods will have the
  32. ;;; coordinate rescaling and clipping automatically taken care of.
  33.  
  34. ;;; During redisplay-pass-1 the only region of the screen the redisplay
  35. ;;; methods are allowed to draw in is the region of the screen currently
  36. ;;; occupied by the screen obj.
  37. (DEFWHOPPER (SCREEN-OBJ :REDISPLAY-PASS-1) (&REST ARGS-TO-METHOD)
  38.   (WITH-DRAWING-INSIDE-REGION (X-OFFSET Y-OFFSET WID HEI)
  39.     (LEXPR-CONTINUE-WHOPPER ARGS-TO-METHOD)))
  40.  
  41. ;;; During redisplay-pass-2 the only part of the screen the redisplay
  42. ;;; methods are allowed to draw in is the max of the region currently
  43. ;;; occupied by the screen obj, and the space that will be occupied by
  44. ;;; the screen obj when redisplay-pass-2 is complete.
  45. (DEFWHOPPER (SCREEN-OBJ :REDISPLAY-PASS-2) (&REST ARGS-TO-METHOD)
  46.   (WITH-DRAWING-INSIDE-REGION (X-OFFSET Y-OFFSET (MAX WID NEW-WID) (MAX HEI NEW-HEI))
  47.     (LEXPR-CONTINUE-WHOPPER ARGS-TO-METHOD)))
  48.  
  49. ;;; SCREEN-BOXES also have methods called redisplay-screen-rows-pass-1,
  50. ;;; and redisplay-screen-rows-pass-2. The clipping and rescaling for
  51. ;;; these methods is similar to the clipping and rescaling for the other
  52. ;;; redisplay-pass-1 and redisplay-pass-2 methods, except that here the
  53. ;;; region of the screen of that is being draw inside is a subpart of
  54. ;;; the screen obj, the screen-box's screen-rows.
  55. (DEFWHOPPER (SCREEN-BOX :REDISPLAY-INFERIORS-PASS-1) (INFS-NEW-MAX-WID INFS-NEW-MAX-HEI
  56.                              &REST ARGS-TO-METHOD)
  57.   (PORT-REDISPLAYING-HISTORY (ACTUAL-OBJ)
  58.     (MULTIPLE-VALUE-BIND (IL IT IR IB)
  59.     (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF)
  60.       (WITH-CLIPPING-INSIDE (IL IT (- WID IL IR) (- HEI IT IB))
  61.     (LEXPR-CONTINUE-WHOPPER INFS-NEW-MAX-WID INFS-NEW-MAX-HEI ARGS-TO-METHOD)))))
  62.  
  63. (DEFWHOPPER (SCREEN-BOX :REDISPLAY-INFERIORS-PASS-2) (&REST ARGS-TO-METHOD)
  64.   (MULTIPLE-VALUE-BIND (IL IT IR IB)
  65.       (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF)
  66.     (WITH-CLIPPING-INSIDE (IL IT (- (MAX WID NEW-WID) IL IR) (- (MAX HEI NEW-HEI) IT IB))
  67.       (LEXPR-CONTINUE-WHOPPER ARGS-TO-METHOD))))
  68.  
  69.  
  70.  
  71. ;;; Deciding about whether or not a screen-obj needs redisplay. Because
  72. ;;; of speed consideration this is split into two different methods:
  73. ;;; :NEEDS-REDISPLAY-PASS-1? and NEEDS-REDISPLAY-PASS-2?. Actually, only
  74. ;;; :needs-redisplay-pass-1? does any work at all, it basically decides
  75. ;;; if the screen-obj needs redisplay, and if it does it sets a flag and
  76. ;;; returns true. Later when :needs-redisplay-pass-2? is called, all it
  77. ;;; has to do is check the flag. (Even later, the flag will get cleared
  78. ;;; by the :got-redisplayed? method).
  79. ;;;
  80. ;;; :NEEDS-REDISPLAY-PASS-1 will return true in any of the following cases:
  81. ;;;
  82. ;;;   The value of the variable *complete-redisplay-in-progress?* is non-nil.
  83. ;;; 
  84. ;;;   The actual obj has changed since the last time the screen
  85. ;;;    obj got redisplayed.
  86. ;;;
  87. ;;;   The amount of space the screen obj is going to have to fit
  88. ;;;    into is smaller than the space it is currently occupying.
  89. ;;;
  90. ;;;   The screen obj was clipped last time it got displayed, and
  91. ;;;    now it has more space to fit into.
  92. ;;;
  93. ;;;  ** NOTE!!! This is another one of those functions that you weird **
  94. ;;;  ** speed freaks will say, "But this could be much faster!". Well **
  95. ;;;  ** sure, but remember people have to be able to read this shit   **
  96. ;;;  ** and figure out what is going on. Also keep in mind that the   **
  97. ;;;  ** compiler optmizes boolean expressions etc.                    **
  98. (DEFMETHOD (SCREEN-OBJ :NEEDS-REDISPLAY-PASS-1?) (&OPTIONAL (MAX-WID NIL) (MAX-HEI NIL))
  99.   (COND ((OR (NOT-NULL *COMPLETE-REDISPLAY-IN-PROGRESS?*)
  100.          (NOT-NULL NEEDS-REDISPLAY-PASS-2?)
  101.          (NOT-NULL FORCE-REDISPLAY-INFS?)
  102.          (< TICK (TELL ACTUAL-OBJ :TICK))
  103.          (AND (NOT-NULL MAX-WID) (< MAX-WID WID))
  104.          (AND (NOT-NULL MAX-HEI) (< MAX-HEI HEI))
  105.          (AND (NOT-NULL X-GOT-CLIPPED?) (NOT-NULL MAX-WID) (> MAX-WID WID))
  106.          (AND (NOT-NULL Y-GOT-CLIPPED?) (NOT-NULL MAX-HEI) (> MAX-HEI HEI)))
  107.      (SETQ NEEDS-REDISPLAY-PASS-2? T))
  108.     (T NIL)))
  109.  
  110. (DEFMETHOD (SCREEN-OBJ :NEEDS-REDISPLAY-PASS-2?) ()
  111.   (OR (NOT-NULL NEEDS-REDISPLAY-PASS-2?)
  112.       (NOT-NULL *COMPLETE-REDISPLAY-IN-PROGRESS?*)))
  113.  
  114. (DEFMETHOD (SCREEN-OBJ :SET-FORCE-REDISPLAY-INFS?) (&REST IGNORE)
  115.   (SETQ FORCE-REDISPLAY-INFS? T)
  116.   (TELL SELF :SET-NEEDS-REDISPLAY-PASS-2? T))
  117.  
  118. (DEFMETHOD (SCREEN-OBJ :SET-NEEDS-REDISPLAY-PASS-2?) (NEW-VALUE)
  119.   (SETQ NEEDS-REDISPLAY-PASS-2? NEW-VALUE)
  120.   (WHEN (NOT-NULL NEW-VALUE)
  121.     (LET ((SUPERIOR (TELL SELF :SUPERIOR)))
  122.       (WHEN (SCREEN-OBJ? SUPERIOR)
  123.         (TELL SUPERIOR :SET-NEEDS-REDISPLAY-PASS-2? T)))))
  124.  
  125. (DEFMETHOD (SCREEN-ROW :GOT-REDISPLAYED) ()
  126.   (SETQ WID NEW-WID
  127.     HEI NEW-HEI
  128.     X-GOT-CLIPPED? NEW-X-GOT-CLIPPED?
  129.     Y-GOT-CLIPPED? NEW-Y-GOT-CLIPPED?
  130.     TICK (TICK)
  131.     NEEDS-REDISPLAY-PASS-2? NIL
  132.     FORCE-REDISPLAY-INFS? NIL
  133.     OUT-OF-SYNCH-MARK NIL))
  134.  
  135. (DEFMETHOD (SCREEN-BOX :GOT-REDISPLAYED) ()
  136.   (SETQ WID NEW-WID
  137.     HEI NEW-HEI
  138.     X-GOT-CLIPPED? NEW-X-GOT-CLIPPED?
  139.     Y-GOT-CLIPPED? NEW-Y-GOT-CLIPPED?
  140.     INF-HOR-SHIFT 0
  141.     TICK (TICK)
  142.     NEEDS-REDISPLAY-PASS-2? NIL
  143.     FORCE-REDISPLAY-INFS? NIL))
  144.  
  145. (DEFMETHOD (ACTUAL-OBJ-MIXIN :TICK) ()
  146.   TICK)
  147.  
  148. (DEFMETHOD (ACTUAL-OBJ-MIXIN :AFTER :MODIFIED) (&REST IGNORE)
  149.   (SETQ TICK (TICK)))
  150.  
  151.  
  152.  
  153. ;;; The real job of these methods is to rebuild the screen structure after
  154. ;;; some change to the actual structure. Before this method runs, the
  155. ;;; screen structure and the actual structure may or may not be in synch,
  156. ;;; but after this method runs the screen and actual structures will be
  157. ;;; in synch. So this method converts old outdated screen structure into
  158. ;;; new up-to-date screen structure.
  159. ;;; The way these methods do their work is to loop through the screen and
  160. ;;; actual structures in parallel, checking as it goes to make sure that
  161. ;;; the screen structure matches the actual structure. Whenever the two
  162. ;;; don't match, the screen structure is patched to make them match. At
  163. ;;; the end of each pass through the loop inf-screen-obj is sure to be
  164. ;;; in synch with inf-actual-obj. At this point inf-screen-obj is given
  165. ;;; a chance to do its own :redisplay-pass-1 (recurse), and then it is
  166. ;;; allowed to make its contribution to the new-wid, new-hei etc. of all
  167. ;;; the superior's inferior screen objs together.
  168.  
  169. (DEFMETHOD (SCREEN-BOX :REDISPLAY-INFERIORS-PASS-1)(INFS-NEW-MAX-WID INFS-NEW-MAX-HEI
  170.                                      &OPTIONAL
  171.                                      (FIRST-INF-X-OFFSET 0)
  172.                                      (FIRST-INF-Y-OFFSET 0)
  173.                                      (SCROLL-TO-INF NIL))
  174.   ;; First we check for port circularity 
  175.   (IF (AND (PORT-BOX? ACTUAL-OBJ) (PORT-HAS-BEEN-DISPLAYED-ENOUGH? ACTUAL-OBJ))
  176.       ;; The Actual Box is part of a circular structure AND we have already displayed the
  177.       ;; port the required number of times, so we
  178.       (PROGN
  179.     ;; erase and remove whatever is in the box, then
  180.     (WHEN (AND (NOT-NULL SCREEN-ROWS) (NOT (BOX-ELLIPSIS-STYLE? SCREEN-ROWS)))
  181.       (LET ((SRS SCREEN-ROWS))
  182.         (TELL SELF :KILL-SCREEN-ROW (CAR SCREEN-ROWS))
  183.         (ERASE-SCREEN-OBJS SRS)
  184.         (QUEUE-SCREEN-OBJS-FOR-DEALLOCATION SRS)))
  185.     ;; If there was an ellipsis marker already there, then we need to erase it in
  186.     ;; order to leave a blank space for the marker to be drawn during pass-2
  187.     (WHEN (BOX-ELLIPSIS-STYLE? SCREEN-ROWS)
  188.       (MULTIPLE-VALUE-BIND (IL IT)
  189.           (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF)
  190.         (FUNCALL (GET SCREEN-ROWS 'ERASE-SELF) IL IT)))
  191.       ;; put a Box ellipsis marker into the inferiors slot of the screen box
  192.       (SETQ SCREEN-ROWS *BOX-ELLIPSIS-CURRENT-STYLE*)
  193.       ;; then return the necessary values
  194.       (MULTIPLE-VALUE-BIND (EWID EHEI)
  195.           (FUNCALL (GET *BOX-ELLIPSIS-CURRENT-STYLE* 'SIZE))
  196.         (VALUES (MIN EWID INFS-NEW-MAX-WID) (MIN EHEI INFS-NEW-MAX-HEI)
  197.             (>   EWID INFS-NEW-MAX-WID) (>   EHEI INFS-NEW-MAX-HEI))))
  198.     
  199.       
  200.       ;; If the port has an ellipsis marker when it shouldn't, then erase and remove it
  201.       (WHEN (AND (PORT-BOX? ACTUAL-OBJ) (BOX-ELLIPSIS-STYLE? SCREEN-ROWS))
  202.     (MULTIPLE-VALUE-BIND (IL IT)
  203.         (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF)
  204.       (FUNCALL (GET SCREEN-ROWS 'ERASE-SELF) IL IT))
  205.     (SETQ SCREEN-ROWS NIL))
  206.       
  207.       ;; Bind some useful vars for the main loop to side effect
  208.       (LET ((*COMPLETE-REDISPLAY-IN-PROGRESS?* (OR *COMPLETE-REDISPLAY-IN-PROGRESS?*
  209.                            FORCE-REDISPLAY-INFS?))
  210.         (INFS-NEW-WID 0)
  211.         (INFS-NEW-HEI 0)
  212.         (INFS-NEW-X-GOT-CLIPPED? NIL)
  213.         (INFS-NEW-Y-GOT-CLIPPED? NIL)
  214.         (INF-X-OFFSET FIRST-INF-X-OFFSET)
  215.         (INF-Y-OFFSET FIRST-INF-Y-OFFSET))
  216.     ;; At the start of each pass through the loop bind inf-screen-obj,
  217.     ;; and inf-actual-obj to the next obj in the screen and actual
  218.     ;; structures respectively.
  219.     (DO ((INF-ACTUAL-OBJ (OR SCROLL-TO-INF
  220.                  (TELL ACTUAL-OBJ :FIRST-INFERIOR-OBJ))
  221.                  (TELL INF-ACTUAL-OBJ :NEXT-OBJ))
  222.          (INF-SCREEN-OBJ (TELL SELF :FIRST-SCREEN-OBJ)
  223.                  (TELL INF-SCREEN-OBJ :NEXT-SCREEN-OBJ)))
  224.         ;; If there are no more inferior screen-objs or if the current state of
  225.         ;; the clipping means that there is no room to display any more inferiors or the
  226.         ;; box is shrunken 
  227.         ;; we quit. If there are any inferior screen-objs left in the old screen
  228.         ;; structure punt them.
  229.         ((OR (NULL INF-ACTUAL-OBJ)
  230.          (TELL SELF :RDP1-OUT-OF-ROOM-TO-DISPLAY-INFERIORS? INFS-NEW-Y-GOT-CLIPPED?)
  231.          (EQ (TELL SELF :DISPLAY-STYLE) ':SHRUNK))
  232.          (WHEN (NOT-NULL INF-SCREEN-OBJ)
  233.            (TELL SELF :RDP1-PUNT-EXTRA-SCREEN-OBJS INF-SCREEN-OBJ))
  234.          (VALUES INFS-NEW-WID INFS-NEW-HEI
  235.              INFS-NEW-X-GOT-CLIPPED? INFS-NEW-Y-GOT-CLIPPED?))
  236.       ;; If for any reason inf-screen-obj doesn't match inf-actual-obj
  237.       ;; we need to patch up the screen structure. This can be fairly
  238.       ;; hairy, so we call in somebody else to do the job.
  239.       (WHEN (OR (NULL INF-SCREEN-OBJ)
  240.             (NEQ (SCREEN-OBJ-ACTUAL-OBJ INF-SCREEN-OBJ) INF-ACTUAL-OBJ))
  241.         (SETQ INF-SCREEN-OBJ (TELL SELF :RDP1-PATCH-OUT-OF-SYNCH-LOSSAGE
  242.                        INF-ACTUAL-OBJ INF-SCREEN-OBJ
  243.                        INF-X-OFFSET INF-Y-OFFSET)))
  244.       
  245.       ;; At this point we know that inf-screen-obj and inf-actual-obj
  246.       ;; match. If it wants to let inf-screen-obj do :redisplay-pass-1.
  247.       (WHEN (TELL INF-SCREEN-OBJ :NEEDS-REDISPLAY-PASS-1? INFS-NEW-MAX-WID
  248.               INFS-NEW-MAX-HEI)
  249.         (TELL INF-SCREEN-OBJ :REDISPLAY-PASS-1 INFS-NEW-MAX-WID
  250.           INFS-NEW-MAX-HEI))
  251.       ;; Finally, let inf-screen-obj make its contibution to the total
  252.       ;; new-wid, new-hei etc. of all the inf-screen-objs.
  253.       (MULTIPLE-VALUE (INFS-NEW-WID INFS-NEW-HEI
  254.                INFS-NEW-X-GOT-CLIPPED? INFS-NEW-Y-GOT-CLIPPED? 
  255.                INF-Y-OFFSET
  256.                INFS-NEW-MAX-HEI)
  257.         ;; inf-screen-obj has to be a screen-row so we don't
  258.         ;; pass INF-X-OFFSET and NEW-MAX-WID
  259.         (TELL INF-SCREEN-OBJ :RDP1-INCREMENT-SUPERIOR-PARAMETERS
  260.           INFS-NEW-WID
  261.           INFS-NEW-HEI
  262.           INFS-NEW-X-GOT-CLIPPED?
  263.           INFS-NEW-Y-GOT-CLIPPED?
  264.           INF-Y-OFFSET
  265.           INFS-NEW-MAX-HEI))))))
  266.  
  267. (DEFMETHOD (SCREEN-BOX :RDP1-OUT-OF-ROOM-TO-DISPLAY-INFERIORS?) (INFS-NEW-Y-GOT-CLIPPED?)
  268.   INFS-NEW-Y-GOT-CLIPPED?)
  269.  
  270. (DEFMETHOD (SCREEN-OBJ :RDP1-PUNT-EXTRA-SCREEN-OBJS) (FIRST-SCREEN-OBJ-TO-PUNT)
  271.   (LET ((SCREEN-OBJS-TO-PUNT (TELL FIRST-SCREEN-OBJ-TO-PUNT :SELF-AND-NEXT-SCREEN-OBJS)))
  272.     (ERASE-SCREEN-OBJS SCREEN-OBJS-TO-PUNT)
  273.     (QUEUE-SCREEN-OBJS-FOR-DEALLOCATION SCREEN-OBJS-TO-PUNT)
  274.     (TELL SELF :KILL-SCREEN-OBJ FIRST-SCREEN-OBJ-TO-PUNT)))
  275.  
  276.  
  277. ;;;this is one of the main screen structure patching routine...
  278. ;;;it examines the state of the screen box so far and, from the
  279. ;;;information given, decides which of several, more specific, screen
  280. ;;;structure patching routines to call
  281.  
  282. (DEFMETHOD (SCREEN-OBJ :RDP1-PATCH-OUT-OF-SYNCH-LOSSAGE)
  283.        (INF-ACTUAL-OBJ INF-SCREEN-OBJ SCREEN-OBJ-X-OFFSET SCREEN-OBJ-Y-OFFSET)
  284.   (LET* ((MATCHING-SCREEN-OBJ
  285.        (TELL INF-ACTUAL-OBJ :ALLOCATE-SCREEN-OBJ-FOR-USE-IN
  286.          (TELL SELF :LOWEST-SCREEN-BOX)))
  287.      (MATCHING-SCREEN-OBJ-SUPERIOR
  288.        (TELL MATCHING-SCREEN-OBJ :SUPERIOR)))
  289.     (COND ((EQ MATCHING-SCREEN-OBJ-SUPERIOR SELF)
  290.        ;; The screen-obj which matches inf-actual-obj must be
  291.        ;; farther along in this screen obj somewhere.
  292.        ;; (One common cause for this is a rubout).
  293.        (TELL SELF :RDP1-PATCH-RUBOUT-INF-STYLE-LOSSAGE-INTERNAL
  294.          MATCHING-SCREEN-OBJ INF-SCREEN-OBJ))
  295.       ((NOT-NULL MATCHING-SCREEN-OBJ-SUPERIOR)
  296.        ;; The screen-obj which matches inf-actual-obj is not in
  297.        ;; in us anywhere,  but it is in use somewhere. (Note that
  298.        ;; its superior must come after us, and at the same level).
  299.        (TELL SELF :RDP1-PATCH-RANDOM-STYLE-LOSSAGE-INTERNAL
  300.          MATCHING-SCREEN-OBJ INF-SCREEN-OBJ SCREEN-OBJ-X-OFFSET SCREEN-OBJ-Y-OFFSET))
  301.       (T
  302.        ;; The screen-obj which matches inf-actual-obj is not in
  303.        ;; use anywhere. This means inf-actual-obj is a new actual-
  304.        ;; obj. (Probably the most common cause for this is an
  305.        ;; append cha).
  306.        (TELL SELF :RDP1-PATCH-NEW-INF-STYLE-LOSSAGE-INTERNAL
  307.          MATCHING-SCREEN-OBJ INF-SCREEN-OBJ SCREEN-OBJ-X-OFFSET SCREEN-OBJ-Y-OFFSET)))))
  308.  
  309. (DEFMETHOD (SCREEN-OBJ :RDP1-PATCH-RUBOUT-INF-STYLE-LOSSAGE-INTERNAL)(MATCHING-SCREEN-OBJ
  310.                                        INF-SCREEN-OBJ)
  311.   ;; Delete and erase the screen objs between inf-screen-obj and matching-
  312.   ;; matching screen-obj, then blt the matching-screen-obj-and-next-screen-objs
  313.   ;; over.
  314.   (LET ((INF-SCREEN-OBJ-AND-NEXT-SCREEN-OBJS
  315.       (TELL INF-SCREEN-OBJ :SELF-AND-NEXT-SCREEN-OBJS)))
  316.     (TELL SELF :DELETE-BETWEEN-SCREEN-OBJS INF-SCREEN-OBJ MATCHING-SCREEN-OBJ)
  317.     ;; **WATCH OUT** At this point we have side-effected the value of
  318.     ;; inf-screen-obj-and-next-screen-objs!!! Its value is now just
  319.     ;; those screen-objs that got deleted. By coincidence, these are the
  320.     ;; screen-objs that need to be erased, and the world is good place.
  321.     ;; Hope that nobody changes :delete-between-screen-objs.
  322.     (MULTIPLE-VALUE-BIND (ERASED-WID ERASED-HEI)
  323.     (SCREEN-OBJS-NEXT-SCREEN-OBJ-DELTA-OFFSETS-WHEN-ERASED
  324.       INF-SCREEN-OBJ-AND-NEXT-SCREEN-OBJS)
  325.       (ERASE-SCREEN-OBJS INF-SCREEN-OBJ-AND-NEXT-SCREEN-OBJS)
  326.       (QUEUE-SCREEN-OBJS-FOR-DEALLOCATION INF-SCREEN-OBJ-AND-NEXT-SCREEN-OBJS)
  327.       (MOVE-SCREEN-OBJS (TELL MATCHING-SCREEN-OBJ :SELF-AND-NEXT-SCREEN-OBJS)
  328.             (- ERASED-WID)
  329.             (- ERASED-HEI))
  330.       MATCHING-SCREEN-OBJ)))
  331.  
  332.  
  333. (DEFMETHOD (SCREEN-OBJ :RDP1-PATCH-NEW-INF-STYLE-LOSSAGE-INTERNAL)
  334.        (MATCHING-SCREEN-OBJ INF-SCREEN-OBJ SCREEN-OBJ-X-OFFSET SCREEN-OBJ-Y-OFFSET)
  335.   ;;Just insert the matching-screen-obj in the right place and we're done.
  336.   (TELL SELF :INSERT-SCREEN-OBJ MATCHING-SCREEN-OBJ INF-SCREEN-OBJ)
  337.   (SET-SCREEN-OBJ-OFFSETS MATCHING-SCREEN-OBJ SCREEN-OBJ-X-OFFSET SCREEN-OBJ-Y-OFFSET)
  338.   MATCHING-SCREEN-OBJ)
  339.  
  340. (DEFMETHOD (SCREEN-ROW :RDP1-INCREMENT-SUPERIOR-PARAMETERS) (INFS-NEW-WID
  341.                                  INFS-NEW-HEI
  342.                                  INFS-NEW-X-GOT-CLIPPED?
  343.                                  INFS-NEW-Y-GOT-CLIPPED?
  344.                                  INF-Y-OFFSET
  345.                                  INFS-NEW-MAX-HEI)
  346.   (VALUES (MAX INFS-NEW-WID NEW-WID)
  347.       (+ INFS-NEW-HEI NEW-HEI)
  348.       (OR INFS-NEW-X-GOT-CLIPPED? NEW-X-GOT-CLIPPED?)
  349.       (OR INFS-NEW-Y-GOT-CLIPPED? NEW-Y-GOT-CLIPPED?)
  350.       (+ INF-Y-OFFSET HEI)
  351.       (- INFS-NEW-MAX-HEI NEW-HEI)))
  352.  
  353.  
  354. ;;;Methods used for redisplaying ROWS
  355. ;;;
  356. ;;;The main difference between redisplaying rows and redisplaying boxes is that rows
  357. ;;;have to know what is going on with their inferiors because chas cannot take care of
  358. ;;;such things as clipping and drawing by themselves (like rows can)
  359. ;;;
  360. ;;;what a row tries to do on REDISPLAY PASS 1 is: it patches up screen structure to be
  361. ;;;in synch with actual structure, marks the point in the row where the initial out
  362. ;;;of synch lossage occured, erases ALL chas past this point and tries REAL HARD to
  363. ;;;preserve the boxes which have already been drawn so they can be bitblted to the right
  364. ;;;place during pass 2.  Drawn boxes which are no longer needed (ones which have been rubbed
  365. ;;;out) are also erased during pass 1.
  366. ;;;
  367. ;;;during REDISPLAY PASS 2, the row then draws in all the characters it has to,
  368. ;;;starting from the point of out of synch lossage since all chas past this point
  369. ;;;will have been erased.  It also bitblts any existing boxes to the right place
  370. ;;;and draws any new boxes that were created
  371.  
  372. (DEFMETHOD (SCREEN-ROW :REDISPLAY-INFERIORS-PASS-1)(INFS-NEW-MAX-WID INFS-NEW-MAX-HEI
  373.                                      &OPTIONAL
  374.                                      (FIRST-INF-X-OFFSET 0)
  375.                                      (FIRST-INF-Y-OFFSET 0))
  376.   (LET ((*COMPLETE-REDISPLAY-IN-PROGRESS?*
  377.       (OR *COMPLETE-REDISPLAY-IN-PROGRESS?* FORCE-REDISPLAY-INFS?))
  378.     (INFS-NEW-WID 0) (INFS-NEW-HEI 0)
  379.     (INFS-NEW-X-GOT-CLIPPED? NIL) (INFS-NEW-Y-GOT-CLIPPED? NIL)
  380.     (INF-X-OFFSET FIRST-INF-X-OFFSET)(INF-Y-OFFSET FIRST-INF-Y-OFFSET)
  381.     ;; intialize the BOXES-TO-DISPLAY variable to all the boxes in the actual row
  382.     ;; as each box is displayed, remove it from the list.
  383.     (BOXES-TO-DISPLAY (TELL ACTUAL-OBJ :BOXES-IN-ROW))
  384.     ;; initialize the out of synch flag.  this flag is tripped whenever the row gets
  385.     ;; out of synch for the first time
  386.     (OUT-OF-SYNCH-ALREADY NIL))
  387.     ;; if the row was vertically clipped, we want to redraw the entire row
  388.     (WHEN Y-GOT-CLIPPED?
  389.      (SETQ OUT-OF-SYNCH-MARK 0
  390.         OUT-OF-SYNCH-ALREADY T)
  391.       (ERASE-CHAS-TO-EOL 0 INF-X-OFFSET INF-Y-OFFSET))
  392.     ;; At the start of each pass through the loop bind inf-screen-obj and inf-actual-obj
  393.     ;; to the next obj in the screen and actual structures respectively.
  394.     (DO* ((CHA-NO 0 (+ CHA-NO 1))
  395.       (INF-ACTUAL-OBJ (TELL ACTUAL-OBJ :CHA-AT-CHA-NO CHA-NO)
  396.               (TELL ACTUAL-OBJ :CHA-AT-CHA-NO CHA-NO))
  397.       (INF-SCREEN-OBJ (NTH CHA-NO SCREEN-CHAS)
  398.               (NTH CHA-NO SCREEN-CHAS)))
  399.      ;; If there are no more inferior screen-objs or if the current state of
  400.      ;; the clipping means that there is no room to display any more
  401.      ;; inferiors we quit. If there are any inferior screen-objs
  402.      ;; left in the old screen structure punt them.
  403.      ((OR (NULL INF-ACTUAL-OBJ)
  404.           (TELL SELF :RDP1-OUT-OF-ROOM-TO-DISPLAY-INFERIORS? INFS-NEW-X-GOT-CLIPPED?))
  405.       (WHEN (NOT-NULL INF-SCREEN-OBJ)
  406.         (TELL SELF :RDP1-PUNT-EXTRA-SCREEN-OBJS-FROM CHA-NO       OUT-OF-SYNCH-ALREADY
  407.                                                  INF-X-OFFSET INF-Y-OFFSET))
  408.       (VALUES INFS-NEW-WID INFS-NEW-HEI INFS-NEW-X-GOT-CLIPPED? INFS-NEW-Y-GOT-CLIPPED?))
  409.       
  410.  
  411.  
  412.       ;; If for any reason inf-screen-obj doesn't match inf-actual-obj
  413.       ;; we need to patch up the screen structure. This can be
  414.       ;; hairy, so we call in somebody else to do the job.
  415.       (WHEN (OR (NULL INF-SCREEN-OBJ)
  416.         (NEQ (ACTUAL-OBJ-OF-SCREEN-OBJ INF-SCREEN-OBJ) INF-ACTUAL-OBJ))
  417.     (UNLESS OUT-OF-SYNCH-ALREADY
  418.       (SETQ OUT-OF-SYNCH-MARK CHA-NO
  419.         OUT-OF-SYNCH-ALREADY T)
  420.       ;; do all the erasing of chas (but NOT boxes) in one pass while we still know where 
  421.       ;; everything is located
  422.       (ERASE-CHAS-TO-EOL CHA-NO INF-X-OFFSET INF-Y-OFFSET))        
  423.     (SETQ INF-SCREEN-OBJ (TELL SELF :RDP1-PATCH-OUT-OF-SYNCH-LOSSAGE
  424.                    INF-ACTUAL-OBJ INF-SCREEN-OBJ
  425.                    INF-X-OFFSET INF-Y-OFFSET
  426.                    CHA-NO)))
  427.       ;; At this point we know that inf-screen-obj and inf-actual-obj
  428.       ;; match. If it wants to (and is a screen-box) let inf-screen-obj do :redisplay-pass-1.
  429.       ;; if inf-screen-obj is a box, then delete it from the BOXES-TO-BE-DISPLAYED list
  430.       (COND ((SCREEN-CHA? INF-SCREEN-OBJ)
  431.          ;; must be a screen cha so the ROW has to check for clipping 
  432.          ;; and increment its own infs-screen-objs parameters
  433.          (MULTIPLE-VALUE (INFS-NEW-WID            INFS-NEW-HEI
  434.                   INFS-NEW-X-GOT-CLIPPED? INFS-NEW-Y-GOT-CLIPPED?
  435.                   INF-X-OFFSET
  436.                   INFS-NEW-MAX-WID)
  437.            (SCREEN-CHA-INCREMENT-SUPERIOR-PARAMETERS INF-SCREEN-OBJ
  438.                              INFS-NEW-WID
  439.                              INFS-NEW-HEI
  440.                              INF-X-OFFSET
  441.                              INFS-NEW-MAX-WID
  442.                              INFS-NEW-MAX-HEI)))
  443.         (T
  444.          ;;must be a box so let the box do some work...
  445.          ;;that is, redisplay if it wants to and then make its contribution to
  446.          ;;all the infs-screen-objs parameters
  447.          (WHEN (TELL INF-SCREEN-OBJ :NEEDS-REDISPLAY-PASS-1? INFS-NEW-MAX-WID
  448.              INFS-NEW-MAX-HEI)
  449.            (TELL INF-SCREEN-OBJ :REDISPLAY-PASS-1 INFS-NEW-MAX-WID
  450.              INFS-NEW-MAX-HEI)
  451.            (UNLESS (TELL INF-SCREEN-OBJ :RDP1-UNCHANGED-WIDTH?)
  452.          (UNLESS OUT-OF-SYNCH-ALREADY
  453.            ;; check the box and if the redisplay has changed changed its
  454.            ;; size, we have to flush the rest of the line
  455.            (SETQ OUT-OF-SYNCH-MARK CHA-NO
  456.              OUT-OF-SYNCH-ALREADY T)
  457.            (ERASE-CHAS-TO-EOL CHA-NO INF-X-OFFSET INF-Y-OFFSET))))
  458.          (MULTIPLE-VALUE (INFS-NEW-WID INFS-NEW-HEI
  459.                   INFS-NEW-X-GOT-CLIPPED? INFS-NEW-Y-GOT-CLIPPED? 
  460.                   INF-X-OFFSET 
  461.                   INFS-NEW-MAX-WID)
  462.            (TELL INF-SCREEN-OBJ :RDP1-INCREMENT-SUPERIOR-PARAMETERS
  463.              INFS-NEW-WID            INFS-NEW-HEI
  464.              INFS-NEW-X-GOT-CLIPPED? INFS-NEW-Y-GOT-CLIPPED?
  465.              INF-X-OFFSET         
  466.              INFS-NEW-MAX-WID))
  467.          ;;delete the box from the list of boxes to display
  468.          (SETQ BOXES-TO-DISPLAY (DELQ INF-ACTUAL-OBJ BOXES-TO-DISPLAY)))))))
  469.  
  470.  
  471.  
  472. (DEFMETHOD (SCREEN-ROW :RDP1-OUT-OF-ROOM-TO-DISPLAY-INFERIORS?) (INFS-NEW-X-GOT-CLIPPED?)
  473.   INFS-NEW-X-GOT-CLIPPED?)
  474.  
  475. (DEFUN EXTRACT-SCREEN-BOXES (LIST-OF-CHAS-OR-BOXES)
  476.   (SUBSET #'SCREEN-BOX? LIST-OF-CHAS-OR-BOXES))
  477.  
  478. (DEFMETHOD (SCREEN-ROW :RDP1-PUNT-EXTRA-SCREEN-OBJS-FROM) (NO-OF-FIRST-OBJ-TO-PUNT
  479.                                 SCREEN-ALTERED? X-COORD Y-COORD)
  480.   (LET* ((SCREEN-OBJS-TO-PUNT (TELL SELF :SCREEN-OBJS-AT-AND-AFTER NO-OF-FIRST-OBJ-TO-PUNT))
  481.      (SCREEN-BOXES-TO-PUNT (EXTRACT-SCREEN-BOXES SCREEN-OBJS-TO-PUNT)))
  482.     (IF SCREEN-ALTERED?
  483.     ;; either the screen structure has been patched and the chas already erased in 
  484.     ;; which case we erase and deallocate the boxes or else we have to erase everything
  485.     ;; which is easy since we still know where everything is since nothing has moved
  486.     (DOLIST (SCREEN-BOX-TO-PUNT SCREEN-BOXES-TO-PUNT)
  487.       (MULTIPLE-VALUE-BIND (BOX-X-OFFSET BOX-Y-OFFSET)
  488.           (TELL SCREEN-BOX-TO-PUNT :OFFSETS)
  489.         (ERASE-SCREEN-BOX SCREEN-BOX-TO-PUNT BOX-X-OFFSET BOX-Y-OFFSET)))
  490.     (ERASE-SCREEN-CHAS SCREEN-OBJS-TO-PUNT X-COORD Y-COORD))
  491.     (QUEUE-SCREEN-OBJS-FOR-DEALLOCATION SCREEN-BOXES-TO-PUNT)
  492.     (TELL SELF :KILL-SCREEN-CHAS-FROM NO-OF-FIRST-OBJ-TO-PUNT)))
  493.  
  494.  
  495. ;;;this is the other main screen structure patching routine...
  496. ;;;it examines the state of the screen row so far and, from the
  497. ;;;information given, decides which of several, more specific, screen
  498. ;;;structure patching routines to call
  499.  
  500. (DEFMETHOD (SCREEN-ROW :RDP1-PATCH-OUT-OF-SYNCH-LOSSAGE) (INF-ACTUAL-OBJ
  501.                                INF-SCREEN-OBJ
  502.                                SCREEN-OBJ-X-OFFSET
  503.                                SCREEN-OBJ-Y-OFFSET
  504.                                CHA-NO)
  505.   (WHEN (OBSELETE-SCREEN-BOX? INF-SCREEN-OBJ)
  506.     ;; if the existing screen character is a screen box and the
  507.     ;; screen box no longer belongs, erase it
  508.     (MULTIPLE-VALUE-BIND (X-COORD Y-COORD)
  509.     (TELL INF-SCREEN-OBJ :OFFSETS)
  510.       (ERASE-SCREEN-BOX INF-SCREEN-OBJ X-COORD Y-COORD)))
  511.   ;; there are two alternatives, either we want to patch up the screen structure with a
  512.   ;; character or else we want to patch it up with a BOX.  Since boxes have EQness, we
  513.   ;; use the boxes in the row as markers.  In other words, we keep on inserting chas as we
  514.   ;; need them until we hit a box--at which point we flush all the chas between where we
  515.   ;; are now and where the box is.  This continues for each box in the row or until the end
  516.   ;; of the line (we run out of real chas)
  517.   (LET* ((MATCHING-SCREEN-OBJ
  518.        (IF (CHA? INF-ACTUAL-OBJ)
  519.            (MAKE-SCREEN-CHA INF-ACTUAL-OBJ)
  520.            (TELL INF-ACTUAL-OBJ :ALLOCATE-SCREEN-OBJ-FOR-USE-IN
  521.              (TELL SELF :LOWEST-SCREEN-BOX)))))
  522.     (COND ((SCREEN-CHA? MATCHING-SCREEN-OBJ)
  523.        (TELL SELF :RDP1-PATCH-CHA-LOSSAGE-INTERNAL MATCHING-SCREEN-OBJ CHA-NO))
  524.       ;;must be a box that wants to be patched
  525.       ((EQ SELF (TELL MATCHING-SCREEN-OBJ :SUPERIOR))
  526.        ;;the screen box is already in the current row
  527.        (TELL SELF :RDP1-PATCH-BOX-IN-ROW-LOSSAGE-INTERNAL MATCHING-SCREEN-OBJ CHA-NO))
  528.       ((NOT-NULL (TELL MATCHING-SCREEN-OBJ :SUPERIOR))
  529.        ;; the screen box exists but is not in the present row
  530.        (TELL SELF :RDP1-PATCH-BOX-NOT-IN-ROW-LOSSAGE-INTERNAL
  531.                MATCHING-SCREEN-OBJ CHA-NO SCREEN-OBJ-X-OFFSET SCREEN-OBJ-Y-OFFSET))
  532.       (T
  533.        ;;the screen box has never been displayed (it was just made)
  534.        (TELL SELF :RDP1-PATCH-NEW-BOX-LOSSAGE-INTERNAL
  535.                    MATCHING-SCREEN-OBJ CHA-NO SCREEN-OBJ-X-OFFSET SCREEN-OBJ-Y-OFFSET)))
  536.     MATCHING-SCREEN-OBJ))
  537.  
  538.  
  539.  
  540. (DEFUN-METHOD GATHER-SCREEN-CHAS SCREEN-ROW (START-NO END-NO)
  541.   (FIRSTN (- END-NO START-NO)
  542.       (NTHCDR START-NO SCREEN-CHAS)))
  543.  
  544. (DEFUN-METHOD GATHER-SCREEN-BOXES SCREEN-ROW (START-NO END-NO)
  545.   (SUBSET #'SCREEN-BOX? (GATHER-SCREEN-CHAS START-NO END-NO)))
  546.  
  547. (DEFUN-METHOD OBSELETE-SCREEN-BOX? SCREEN-ROW (TEST-SCREEN-CHA)
  548.   (WHEN (SCREEN-BOX? TEST-SCREEN-CHA)
  549.     (NOT (MEMQ (TELL TEST-SCREEN-CHA :ACTUAL-OBJ) (TELL ACTUAL-OBJ :BOXES-IN-ROW)))))
  550.  
  551. ;;;specific screen structure patching methods...
  552.  
  553. (DEFMETHOD (SCREEN-ROW :RDP1-PATCH-CHA-LOSSAGE-INTERNAL) (MATCHING-SCREEN-OBJ POSITION)
  554.   (TELL SELF :INSERT-SCREEN-CHA-AT-CHA-NO MATCHING-SCREEN-OBJ POSITION))
  555.  
  556. (DEFMETHOD (SCREEN-ROW :RDP1-PATCH-BOX-IN-ROW-LOSSAGE-INTERNAL) (MATCHING-SCREEN-BOX POSITION)
  557.   (LET ((BOX-LOCATION (FIND-POSITION-IN-LIST MATCHING-SCREEN-BOX SCREEN-CHAS)))
  558.     ;; flush all the intervening chas
  559.     (TELL SELF :DELETE-SCREEN-CHAS-FROM-TO POSITION BOX-LOCATION)))
  560.  
  561. (DEFMETHOD (SCREEN-ROW :RDP1-PATCH-BOX-NOT-IN-ROW-LOSSAGE-INTERNAL) (MATCHING-SCREEN-BOX
  562.                                       POSITION
  563.                                       SCREEN-CHA-X-OFFSET
  564.                                       SCREEN-CHA-Y-OFFSET)
  565.   ;; First we need to get matching-screen-obj-and-next-screen-objs. Then
  566.   ;; we erase these screen objs, kill them from the superior they are in,
  567.   ;; and insert them in this superior.
  568.   (LET ((MATCHING-SCREEN-BOX-AND-NEXT-SCREEN-CHAS
  569.        (TELL MATCHING-SCREEN-BOX :SELF-AND-NEXT-SCREEN-CHAS))
  570.      (MATCHING-SCREEN-BOX-SCREEN-ROW
  571.        (TELL MATCHING-SCREEN-BOX :SCREEN-ROW)))
  572.     (WITH-ORIGIN-AT ((- (SCREEN-OBJ-X-OFFSET MATCHING-SCREEN-BOX-SCREEN-ROW) X-OFFSET)
  573.                (- (SCREEN-OBJ-Y-OFFSET MATCHING-SCREEN-BOX-SCREEN-ROW) Y-OFFSET))
  574.       (MULTIPLE-VALUE-BIND (X-COORD Y-COORD)
  575.       (TELL MATCHING-SCREEN-BOX :OFFSETS)
  576.     (ERASE-SCREEN-CHAS MATCHING-SCREEN-BOX-AND-NEXT-SCREEN-CHAS X-COORD Y-COORD)))
  577.     (TELL MATCHING-SCREEN-BOX-SCREEN-ROW :KILL-SCREEN-CHA MATCHING-SCREEN-BOX)
  578.     (TELL SELF :INSERT-SCREEN-CHAS-AT-CHA-NO MATCHING-SCREEN-BOX-AND-NEXT-SCREEN-CHAS
  579.        POSITION)
  580.     (DOLIST (SCR-BOX (EXTRACT-SCREEN-BOXES MATCHING-SCREEN-BOX-AND-NEXT-SCREEN-CHAS))
  581.       (SET-SCREEN-OBJ-OFFSETS SCR-BOX SCREEN-CHA-X-OFFSET SCREEN-CHA-Y-OFFSET))))
  582.  
  583. (DEFMETHOD (SCREEN-ROW :RDP1-PATCH-NEW-BOX-LOSSAGE-INTERNAL) (MATCHING-SCREEN-BOX
  584.                                    POSITION
  585.                                    SCREEN-CHA-X-OFFSET
  586.                                    SCREEN-CHA-Y-OFFSET)
  587.   ;; just insert the new box in the right place and we're done
  588.   (TELL SELF :INSERT-SCREEN-CHA-AT-CHA-NO MATCHING-SCREEN-BOX POSITION)
  589.   (SET-SCREEN-OBJ-OFFSETS MATCHING-SCREEN-BOX SCREEN-CHA-X-OFFSET SCREEN-CHA-Y-OFFSET))
  590.  
  591.  
  592.  
  593. (DEFMETHOD (SCREEN-BOX :RDP1-UNCHANGED-WIDTH?) ()
  594.   (ZEROP (- NEW-WID WID)))
  595.  
  596. (DEFUN SCREEN-CHA-INCREMENT-SUPERIOR-PARAMETERS (SCREEN-CHA
  597.                          INFS-NEW-WID
  598.                          INFS-NEW-HEI
  599.                          INF-X-OFFSET  
  600.                          INFS-NEW-MAX-WID
  601.                          INFS-NEW-MAX-HEI)
  602.   (LET* ((FONT (FONT-NO SCREEN-CHA))
  603.      (CODE (CHA-CODE SCREEN-CHA))
  604.      (WID (CHA-WID FONT CODE))
  605.      (HEI (CHA-HEI FONT)))
  606.     (VALUES (+ INFS-NEW-WID WID)
  607.         (MAX INFS-NEW-HEI HEI)
  608.         (> WID INFS-NEW-MAX-WID)
  609.         (> HEI INFS-NEW-MAX-HEI)
  610.         (+ INF-X-OFFSET WID)
  611.         (- INFS-NEW-MAX-WID WID))))
  612.  
  613. ;;;only boxes and rows should be getting this message (NOT chas)
  614. (DEFMETHOD (SCREEN-BOX :RDP1-INCREMENT-SUPERIOR-PARAMETERS) (INFS-NEW-WID
  615.                                  INFS-NEW-HEI
  616.                                  INFS-NEW-X-GOT-CLIPPED?
  617.                                  INFS-NEW-Y-GOT-CLIPPED?
  618.                                  INF-X-OFFSET
  619.                                  INFS-NEW-MAX-WID)
  620.   (VALUES (+ INFS-NEW-WID NEW-WID)
  621.       (MAX INFS-NEW-HEI NEW-HEI)
  622.       (OR INFS-NEW-X-GOT-CLIPPED? NEW-X-GOT-CLIPPED?)
  623.       (OR INFS-NEW-Y-GOT-CLIPPED? NEW-Y-GOT-CLIPPED?)
  624.       (+ INF-X-OFFSET WID)
  625.       (- INFS-NEW-MAX-WID NEW-WID)))
  626.  
  627.  
  628.  
  629. (COMMENT
  630. ;; Until we introduce chas that are allowed to change their font,
  631. ;; all the redisplay-pass-1 method for screen chas has to do is compute
  632. ;; the new size and new got clipped of the screen cha. There are two
  633. ;; cases for this:
  634. ;;    There is enough room to fit the entire screen cha:
  635. ;;     The screen cha takes up all the room it needs and
  636. ;;     doesn't get clipped.
  637. ;;    There isn't enough room to fit the entire screen cha:
  638. ;;     The screen cha takes up as much of its ideal size
  639. ;;     as it can get (this prevents the next screen cha
  640. ;;     from trying to display itself at this screen cha's
  641. ;;     position), and does get clipped.
  642.  
  643. (DEFMETHOD (SCREEN-CHA :REDISPLAY-PASS-1) (MAX-WID MAX-HEI)
  644.   (LET* ((CHA-CODE (TELL ACTUAL-OBJ :CHA-CODE))
  645.      (FONT-NO (TELL ACTUAL-OBJ :FONT-NO))
  646.      (IDEAL-WID (CHA-WID FONT-NO CHA-CODE))
  647.      (IDEAL-HEI (CHA-HEI FONT-NO)))
  648.     (VALUES (SETQ NEW-WID (MIN IDEAL-WID MAX-WID))
  649.         (SETQ NEW-HEI (MIN IDEAL-HEI MAX-HEI))
  650.         (SETQ NEW-X-GOT-CLIPPED? (> IDEAL-WID MAX-WID))
  651.         (SETQ NEW-Y-GOT-CLIPPED? (> IDEAL-HEI MAX-HEI)))))
  652. )
  653.  
  654.  
  655.  
  656. (DEFMETHOD (SCREEN-ROW :REDISPLAY-PASS-1) (MAX-WID MAX-HEI)
  657.   (MULTIPLE-VALUE (NEW-WID NEW-HEI NEW-X-GOT-CLIPPED? NEW-Y-GOT-CLIPPED?)
  658.     (TELL SELF :REDISPLAY-INFERIORS-PASS-1 MAX-WID MAX-HEI))
  659.   (MAXIMIZE NEW-HEI (CHA-HEI *CURRENT-FONT-NO*)))
  660.  
  661. (DEFMETHOD (SCREEN-BOX :REDISPLAY-PASS-1) (MAX-WID MAX-HEI)
  662.   (LET ((NEW-BOX-TYPE (TELL ACTUAL-OBJ :TYPE)))
  663.     (MULTIPLE-VALUE-BIND (L-BORDER-WID T-BORDER-WID R-BORDER-WID B-BORDER-WID)
  664.     (BOX-BORDERS-FN ':BORDER-WIDS NEW-BOX-TYPE SELF)
  665.       (MULTIPLE-VALUE-BIND (MIN-WID MIN-HEI)
  666.       (BOX-BORDERS-FN ':MINIMUM-SIZE NEW-BOX-TYPE SELF)
  667.     (MULTIPLE-VALUE-BIND (FIXED-WID FIXED-HEI)
  668.         (TELL SELF :FIXED-SIZE)
  669.       (LET (;; If the screen-box has a fixed size, then the fixed
  670.         ;; size effectively sets both upper and lower limits
  671.         ;; on the size of the box.
  672.         (REAL-MAX-WID (IF (NULL FIXED-WID)
  673.                   MAX-WID
  674.                   (MIN MAX-WID (+ FIXED-WID L-BORDER-WID R-BORDER-WID))))
  675.         (REAL-MAX-HEI (IF (NULL FIXED-HEI)
  676.                   MAX-HEI
  677.                   (MIN MAX-HEI (+ FIXED-HEI T-BORDER-WID B-BORDER-WID))))
  678.         (REAL-MIN-WID (IF (NULL FIXED-WID)
  679.                   MIN-WID
  680.                   (MAX MIN-WID (+ FIXED-WID L-BORDER-WID R-BORDER-WID))))
  681.         (REAL-MIN-HEI (IF (NULL FIXED-HEI)
  682.                   MIN-HEI
  683.                   (MAX MIN-HEI (+ FIXED-HEI T-BORDER-WID B-BORDER-WID)))))
  684.         (SETQ NEW-WID (+ L-BORDER-WID R-BORDER-WID)
  685.           NEW-HEI (+ T-BORDER-WID B-BORDER-WID))
  686.         ;; Now that we know how much room the borders are going to
  687.         ;; take up, and we know the real max size of the screen-box,
  688.         ;; we can go off and figure out how much space the screen-rows
  689.         ;; are going to take up.
  690.         (MULTIPLE-VALUE-BIND (ROWS-NEW-WID ROWS-NEW-HEI
  691.                   ROWS-NEW-X-GOT-CLIPPED? ROWS-NEW-Y-GOT-CLIPPED?)
  692.         (TELL SELF :REDISPLAY-INFERIORS-PASS-1 (- REAL-MAX-WID NEW-WID)
  693.                                                (- REAL-MAX-HEI NEW-HEI)
  694.                                L-BORDER-WID
  695.                                T-BORDER-WID
  696.                                SCROLL-TO-ACTUAL-ROW)
  697.           (INCF NEW-WID ROWS-NEW-WID)
  698.           (INCF NEW-HEI ROWS-NEW-HEI)
  699.           ;; Make sure that we are at least as big as our minimum size.
  700.           (SETQ NEW-WID (MIN (MAX NEW-WID REAL-MIN-WID) REAL-MAX-WID)
  701.             NEW-HEI (MIN (MAX NEW-HEI REAL-MIN-HEI) REAL-MAX-HEI)
  702.             NEW-X-GOT-CLIPPED? (AND (OR (< REAL-MAX-WID REAL-MIN-WID)
  703.                         ROWS-NEW-X-GOT-CLIPPED?)
  704.                         (OR (NOT FIXED-WID)
  705.                         (> FIXED-WID MAX-WID)))
  706.             NEW-Y-GOT-CLIPPED? (AND (OR (< REAL-MAX-HEI REAL-MIN-HEI)
  707.                         ROWS-NEW-Y-GOT-CLIPPED?)
  708.                          (OR (NOT FIXED-HEI)
  709.                         (> FIXED-HEI MAX-HEI))))
  710.           ;; What hair!!! If we are changing size, then we need to
  711.           ;; erase the part of our borders that need are going to
  712.           ;; need erasing.
  713.           (COND ((NOT-NULL FORCE-REDISPLAY-INFS?)
  714.              ;; If we are being asked to completely redraw our inferiors,
  715.              ;; then we have to blank that area of the screen. We don't
  716.              ;; use erase-screen-obj to do this because we still want to
  717.              ;; "take up" that space.
  718.              (DRAW-RECTANGLE TV:ALU-ANDCA WID HEI 0 0))            
  719.             ((NOT-NULL *COMPLETE-REDISPLAY-IN-PROGRESS?*))
  720.             ((NEQ BOX-TYPE NEW-BOX-TYPE)
  721.              (BOX-BORDERS-FN
  722.                ':CHANGE-SIZE-PASS-1 BOX-TYPE SELF WID HEI NEW-WID NEW-HEI 0 0))
  723.             ((NOT (STRING-EQUAL NAME (TELL-CHECK-NIL (TELL ACTUAL-OBJ :NAME-ROW)
  724.                                  :TEXT-STRING)))
  725.              (BOX-BORDERS-FN
  726.                ':CHANGE-NAME-PASS-1 BOX-TYPE SELF WID HEI NEW-WID NEW-HEI 0 0))
  727.             ((AND (OR ( WID NEW-WID) ( HEI NEW-HEI))
  728.               (NEQ Y-GOT-CLIPPED? NEW-Y-GOT-CLIPPED?))
  729.              ;; what this REALLY wants to check is if the tab got clipped vertically
  730.              (BOX-BORDERS-FN
  731.                ':CHANGE-NAME-PASS-1 BOX-TYPE SELF WID HEI NEW-WID NEW-HEI 0 0))
  732.             ((OR ( WID NEW-WID) ( HEI NEW-HEI))
  733.              (BOX-BORDERS-FN
  734.                ':CHANGE-SIZE-PASS-1 BOX-TYPE SELF WID HEI NEW-WID NEW-HEI 0 0)))
  735.           (TELL SELF :ADJUST-INFERIOR-OFFSETS-AFTER-NAMING
  736.             L-BORDER-WID (NULL (TELL ACTUAL-OBJ :NAME-ROW)))
  737.           (VALUES NEW-WID NEW-HEI NEW-X-GOT-CLIPPED? NEW-Y-GOT-CLIPPED?))))))))
  738.  
  739. (DEFMETHOD (SCREEN-BOX :ADJUST-INFERIOR-OFFSETS-AFTER-NAMING) (&OPTIONAL(FIRST-INF-X-OFFSET 0)
  740.                                     (FORCE-P NIL))
  741.   ;; we can't just blit the rows over during pass 1 because we are being clipped to our
  742.   ;; old wid and NOT how big we WANT to be
  743.   (WHEN (#+SYMBOLICS LISTP #-SYMBOLICS CONSP SCREEN-ROWS)
  744.     (LET ((NAME-ROW (TELL ACTUAL-OBJ :NAME-ROW))
  745.       (DELTA-X (- FIRST-INF-X-OFFSET (OR (AND SCREEN-ROWS
  746.                           (SCREEN-OBJ-X-OFFSET (CAR SCREEN-ROWS)))
  747.                          0))))
  748.       (COND ((AND (OR NAME-ROW FORCE-P)(EQ (TELL SELF :DISPLAY-STYLE) ':SHRUNK))
  749.          (MULTIPLE-VALUE-BIND (L-OLD-WID T-OLD-WID R-OLD-WID B-OLD-WID)
  750.          (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF ':OLD)
  751.            (DRAW-RECTANGLE TV:ALU-ANDCA (- WID L-OLD-WID R-OLD-WID)
  752.                    (- HEI T-OLD-WID B-OLD-WID) L-OLD-WID T-OLD-WID)))
  753.         ((AND (OR NAME-ROW FORCE-P) (NOT (ZEROP DELTA-X)))
  754.          (SETQ INF-HOR-SHIFT DELTA-X))))))
  755.  
  756. (DEFMETHOD (GRAPHICS-SCREEN-BOX :ADJUST-INFERIOR-OFFSETS-AFTER-NAMING)(&OPTIONAL
  757.                                     (FIRST-INF-X-OFFSET 0)
  758.                                     (FORCE-P NIL))
  759.   ;; we can't just blit the graphics sheet over during pass 1 because we are being clipped
  760.   ;; to our old wid and NOT how big we want to be
  761.   (LET ((NAME-ROW (TELL ACTUAL-OBJ :NAME-ROW))
  762.     (DELTA-X (- FIRST-INF-X-OFFSET (OR (AND (NOT-NULL (TELL SELF :SCREEN-SHEET))
  763.                         (GRAPHICS-SCREEN-SHEET-X-OFFSET
  764.                           (TELL SELF :SCREEN-SHEET)))
  765.                        0))))
  766.     (COND ((EQ (TELL SELF :DISPLAY-STYLE) ':SHRUNK)
  767.        (MULTIPLE-VALUE-BIND (L-OLD-WID T-OLD-WID R-OLD-WID B-OLD-WID)
  768.            (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF ':OLD)
  769.          (DRAW-RECTANGLE TV:ALU-ANDCA (- WID L-OLD-WID R-OLD-WID)
  770.                               (- HEI T-OLD-WID B-OLD-WID) L-OLD-WID T-OLD-WID)))
  771.       ((AND (OR NAME-ROW FORCE-P) (NOT (ZEROP DELTA-X)))
  772.        (SETQ INF-HOR-SHIFT DELTA-X)))))
  773.  
  774. (DEFMETHOD (SCREEN-BOX :SET-SCROLL-TO-ACTUAL-ROW) (NEW-VALUE)
  775.   (UNLESS (EQ NEW-VALUE SCROLL-TO-ACTUAL-ROW)
  776.     (WHEN (MEMQ NEW-VALUE (TELL-CHECK-NIL ACTUAL-OBJ :ROWS))
  777.       (SETQ SCROLL-TO-ACTUAL-ROW NEW-VALUE)
  778.       (TELL SELF :SET-FORCE-REDISPLAY-INFS? T))))
  779.  
  780. (DEFMETHOD (SCREEN-BOX :SCROLL-DN-ONE-SCREEN-BOX) ()
  781.   (LET ((LAST-SCREEN-ROW (CAR (LAST SCREEN-ROWS))))
  782.     (UNLESS (NULL LAST-SCREEN-ROW)
  783.       (TELL SELF :SET-SCROLL-TO-ACTUAL-ROW (SCREEN-OBJ-ACTUAL-OBJ LAST-SCREEN-ROW)))))
  784.  
  785. (DEFMETHOD (SCREEN-BOX :SCROLL-UP-ONE-SCREEN-BOX) ()
  786.   (UNLESS (OR (NULL ACTUAL-OBJ) (NULL SCREEN-ROWS))
  787.     (ENSURE-ROW-IS-DISPLAYED (SCREEN-OBJ-ACTUAL-OBJ (CAR SCREEN-ROWS)) SELF -1 T)))
  788.  
  789. (DEFVAR *SHRUNK-BOX-WID* 20.)
  790. (DEFVAR *SHRUNK-BOX-HEI* 10.)
  791.  
  792.  
  793.  
  794. (DEFUN-METHOD DRAW-PORT-BOX-ELLIPSIS? SCREEN-BOX ()
  795.   (AND (PORT-BOX? ACTUAL-OBJ)
  796.        (BOX-ELLIPSIS-STYia? SCREEN-ROWS)))
  797.  
  798. (DEFUN-METHOD DRAW-PORT-BOX-ELLIPSIS SCREEN-BOX (X Y)
  799.   (FUNCALL (GET SCREEN-ROWS 'DRAW-SELF) X Y))
  800.  
  801. (DEFMETHOD (SCREEN-BOX :REDISPLAY-INFERIORS-PASS-2) ()
  802.   (IF (DRAW-PORT-BOX-ELLIPSIS?)
  803.       (MULTIPLE-VALUE-BIND (IL IT)
  804.       (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF)
  805.     (DRAW-PORT-BOX-ELLIPSIS IL IT))
  806.       (DO* ((*COMPLETE-REDISPLAY-IN-PROGRESS?* (OR *COMPLETE-REDISPLAY-IN-PROGRESS?*
  807.                            FORCE-REDISPLAY-INFS?))
  808.         (INF-SCREEN-OBJS (TELL SELF :INFERIORS) (CDR INF-SCREEN-OBJS))
  809.         (INF-SCREEN-OBJ (CAR INF-SCREEN-OBJS) (CAR INF-SCREEN-OBJS)))
  810.        ((NULL INF-SCREEN-OBJS))
  811.     (WHEN (TELL INF-SCREEN-OBJ :NEEDS-REDISPLAY-PASS-2?)
  812.       (MULTIPLE-VALUE-BIND (NEXT-SCREEN-OBJ-DELTA-X NEXT-SCREEN-OBJ-DELTA-Y)
  813.           (TELL INF-SCREEN-OBJ :RDINF-P2-NEXT-SCREEN-OBJ-DELTA-OFFSETS)
  814.         (COND ((OR (PLUSP NEXT-SCREEN-OBJ-DELTA-X)
  815.                (PLUSP NEXT-SCREEN-OBJ-DELTA-Y))
  816.            (MOVE-SCREEN-OBJS (CDR INF-SCREEN-OBJS) NEXT-SCREEN-OBJ-DELTA-X
  817.                      NEXT-SCREEN-OBJ-DELTA-Y)
  818.            (TELL INF-SCREEN-OBJ :REDISPLAY-PASS-2))
  819.           ((OR (MINUSP NEXT-SCREEN-OBJ-DELTA-X)
  820.                (MINUSP NEXT-SCREEN-OBJ-DELTA-Y))
  821.            (TELL INF-SCREEN-OBJ :REDISPLAY-PASS-2)
  822.            (MOVE-SCREEN-OBJS (CDR INF-SCREEN-OBJS) NEXT-SCREEN-OBJ-DELTA-X
  823.                      NEXT-SCREEN-OBJ-DELTA-Y))
  824.           (T
  825.            (TELL INF-SCREEN-OBJ :REDISPLAY-PASS-2))))))))
  826.  
  827. (DEFMETHOD (SCREEN-ROW :RDINF-P2-NEXT-SCREEN-OBJ-DELTA-OFFSETS) ()
  828.   (VALUES 0 (- NEW-HEI HEI)))
  829.  
  830. ;;;this can be optimized (later...)
  831. (DEFMETHOD (SCREEN-ROW :REDISPLAY-INFERIORS-PASS-2) ()
  832.   (LET* ((*COMPLETE-REDISPLAY-IN-PROGRESS?*
  833.        (OR *COMPLETE-REDISPLAY-IN-PROGRESS?* FORCE-REDISPLAY-INFS?))
  834.      (INF-X-OFFSET 0)
  835.      (INF-Y-OFFSET 0)
  836.      (START-POSITION (IF (OR *COMPLETE-REDISPLAY-IN-PROGRESS?*
  837.                  (NULL OUT-OF-SYNCH-MARK))
  838.                  0
  839.                  OUT-OF-SYNCH-MARK))
  840.      (BOXES-TO-DISPLAY (EXTRACT-SCREEN-BOXES (NTHCDR START-POSITION SCREEN-CHAS))))
  841.     (DO* ((CHA-NO 0 (+ CHA-NO 1))
  842.       (INF-SCREEN-OBJS (NTHCDR CHA-NO SCREEN-CHAS) (NTHCDR CHA-NO SCREEN-CHAS))
  843.       (INF-SCREEN-OBJ (CAR INF-SCREEN-OBJS) (CAR INF-SCREEN-OBJS)))  
  844.      ((NULL INF-SCREEN-OBJS))
  845.       (COND ((< CHA-NO START-POSITION))        ;don't need to do any drawing yet
  846.         ((AND (SCREEN-CHA? INF-SCREEN-OBJ)
  847.           ( (RDINF-P2-NEXT-SCREEN-BOX-DELTA-X-OFFSET BOXES-TO-DISPLAY
  848.                                   INF-SCREEN-OBJ
  849.                                   INF-X-OFFSET)
  850.              0))
  851.          ;; we want to draw a cha AND there is enough room to do it without having to move
  852.          ;; any boxes
  853.          (DRAW-CHA TV:ALU-IOR (FONT-NO INF-SCREEN-OBJ) (CHA-CODE INF-SCREEN-OBJ)
  854.                INF-X-OFFSET INF-Y-OFFSET))
  855.         ((SCREEN-CHA? INF-SCREEN-OBJ)
  856.          ;; we have to move some boxes out of the way before we can draw the next cha
  857.          (MOVE-SCREEN-BOXES BOXES-TO-DISPLAY
  858.                 (RDINF-P2-NEXT-SCREEN-BOX-DELTA-X-OFFSET BOXES-TO-DISPLAY
  859.                                      INF-SCREEN-OBJ
  860.                                      INF-X-OFFSET)
  861.                 0)
  862.          (DRAW-CHA TV:ALU-IOR (FONT-NO INF-SCREEN-OBJ) (CHA-CODE INF-SCREEN-OBJ)
  863.                INF-X-OFFSET INF-Y-OFFSET))
  864.         ;; must be a box that wants to be displayed
  865.         (T (IF (EQ INF-SCREEN-OBJ (CAR BOXES-TO-DISPLAY))
  866.            (RDINF-P2-PATCH-BOX-LOSSAGE BOXES-TO-DISPLAY INF-X-OFFSET)
  867.            (FERROR "The current screen object ~S does not match with the first screen
  868. box ~S" INF-SCREEN-OBJ (CAR BOXES-TO-DISPLAY)))
  869.            (SETQ BOXES-TO-DISPLAY (DELQ INF-SCREEN-OBJ BOXES-TO-DISPLAY))))
  870.       (SETQ INF-X-OFFSET (RDINF-P2-INCREMENT-OFFSET INF-SCREEN-OBJ INF-X-OFFSET)))))
  871.     
  872. (DEFUN RDINF-P2-PATCH-BOX-LOSSAGE (BOXES-TO-PATCH CURRENT-X-OFFSET)
  873.   (LET* ((BOX-TO-PATCH (CAR BOXES-TO-PATCH))
  874.      (DELTA-X (- CURRENT-X-OFFSET (SCREEN-OBJ-X-OFFSET BOX-TO-PATCH)))
  875.      (BOXES-LEFT (CDR BOXES-TO-PATCH))
  876.      (NEXT-BOX-OFFSET (RDINF-P2-NEXT-SCREEN-BOX-DELTA-X-OFFSET BOXES-LEFT
  877.                                    BOX-TO-PATCH
  878.                                    CURRENT-X-OFFSET)))
  879.     (UNLESS (ZEROP DELTA-X)
  880.       ;; move the box to the right place
  881.       (MOVE-SCREEN-BOXES BOXES-TO-PATCH DELTA-X 0))
  882.     (UNLESS ( NEXT-BOX-OFFSET 0)
  883.       ;; if the other boxes are in the way move them out of the way
  884.       (MOVE-SCREEN-BOXES BOXES-LEFT NEXT-BOX-OFFSET 0))
  885.     (WHEN (TELL BOX-TO-PATCH :NEEDS-REDISPLAY-PASS-2?)
  886.       ;; if the box wants to, let it do a redisplay pass 2
  887.       (TELL BOX-TO-PATCH :REDISPLAY-PASS-2))))
  888.  
  889. (DEFUN RDINF-P2-NEXT-SCREEN-BOX-DELTA-X-OFFSET (SCREEN-BOXES-LEFT
  890.                            CURRENT-SCREEN-OBJECT CURRENT-X-OFFSET)
  891.   (IF (NULL SCREEN-BOXES-LEFT)
  892.       0
  893.       (- (RDINF-P2-NEXT-SCREEN-OBJ-X-OFFSET CURRENT-SCREEN-OBJECT CURRENT-X-OFFSET)
  894.      (SCREEN-OBJ-X-OFFSET (CAR SCREEN-BOXES-LEFT)))))
  895.  
  896. (DEFUN RDINF-P2-NEXT-SCREEN-OBJ-X-OFFSET (CURRENT-SCREEN-OBJ CURRENT-X-OFFSET)
  897.   (+ CURRENT-X-OFFSET (SCREEN-OBJECT-NEW-WIDTH CURRENT-SCREEN-OBJ)))
  898.  
  899. (DEFUN RDINF-P2-INCREMENT-OFFSET (SCREEN-CHA-OR-BOX OLD-X-OFFSET)
  900.   (+ OLD-X-OFFSET (SCREEN-OBJECT-WIDTH SCREEN-CHA-OR-BOX)))
  901.  
  902. (DEFMETHOD (SCREEN-ROW :REDISPLAY-PASS-2) ()
  903.   (TELL SELF :REDISPLAY-INFERIORS-PASS-2)
  904.   (TELL SELF :GOT-REDISPLAYED))
  905.  
  906. (DEFUN-METHOD BRAND-NEW? SCREEN-OBJ () (= TICK -1))
  907.  
  908. (DEFMETHOD (SCREEN-BOX :REDISPLAY-PASS-2) ()
  909.   (LET ((NEW-BOX-TYPE (TELL ACTUAL-OBJ :TYPE)))   
  910.     (COND ((EQ (TELL SELF :DISPLAY-STYLE) ':SHRUNK)
  911.        (TELL SELF :NAME-AND-INPUTS-ONLY))
  912.       (T (UNLESS (OR (ZEROP INF-HOR-SHIFT)
  913.              (NOT (#+SYMBOLICS LISTP #-SYMBOLICS CONSP SCREEN-ROWS)))
  914.            ;; we have to move the inferiors here in rdp2 because the clipping
  915.            ;; in rdp1 is too restrictive
  916.            (MOVE-INFERIOR-SCREEN-OBJS SCREEN-ROWS INF-HOR-SHIFT 0))
  917.          (TELL SELF :REDISPLAY-INFERIORS-PASS-2)))
  918.     ;; Now deal with the Borders, If they are completely
  919.     ;; erased, redraw them from scratch. If we are changing
  920.     ;; size, redraw the parts that pass-1 erased.
  921.     (COND ((NOT-NULL *COMPLETE-REDISPLAY-IN-PROGRESS?*)
  922.        (BOX-BORDERS-FN ':DRAW BOX-TYPE SELF NEW-WID NEW-HEI 0 0))
  923.       ((NEQ NEW-BOX-TYPE BOX-TYPE)
  924.        (BOX-BORDERS-FN
  925.          ':CHANGE-SIZE-PASS-2 NEW-BOX-TYPE SELF WID HEI NEW-WID NEW-HEI 0 0)
  926.        (SETQ BOX-TYPE NEW-BOX-TYPE))
  927.       ((NOT (STRING-EQUAL NAME (TELL-CHECK-NIL (TELL ACTUAL-OBJ :NAME-ROW)
  928.                            :TEXT-STRING)))
  929.        (BOX-BORDERS-FN
  930.          ':CHANGE-NAME-PASS-2 BOX-TYPE SELF WID HEI NEW-WID NEW-HEI 0 0)
  931.        (SETQ NAME (TELL-CHECK-NIL (TELL ACTUAL-OBJ :NAME-ROW) :TEXT-STRING)))
  932.       ((AND (OR ( WID NEW-WID) ( HEI NEW-HEI))
  933.         (OR (BRAND-NEW?) (NEQ Y-GOT-CLIPPED? NEW-Y-GOT-CLIPPED?)))
  934.        ;; what this REALLY wants to check is if the tab got clipped vertically
  935.        (BOX-BORDERS-FN
  936.          ':CHANGE-NAME-PASS-2 BOX-TYPE SELF WID HEI NEW-WID NEW-HEI 0 0))
  937.        ((OR ( WID NEW-WID) ( HEI NEW-HEI))
  938.         (BOX-BORDERS-FN
  939.           ':CHANGE-SIZE-PASS-2 BOX-TYPE SELF WID HEI NEW-WID NEW-HEI 0 0)))
  940.     ;; Make a note of the fact that this screen box has
  941.     ;; been redisplayed (pass-1 and pass-2 complete).
  942.     (TELL SELF :GOT-REDISPLAYED)))
  943.  
  944. (DEFMETHOD (SCREEN-BOX :GRAY-BODY) ()
  945.   (MULTIPLE-VALUE-BIND (IL IT IB IR)
  946.       (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF)
  947.     (LET ((INSIDE-WID (- NEW-WID (+ IR IL)))
  948.       (INSIDE-HEI (- NEW-HEI (+ IB IT))))
  949.       (WITH-DRAWING-INSIDE-REGION (IL IT INSIDE-WID INSIDE-HEI)
  950.     (BITBLT-TO-SCREEN
  951.       TV:ALU-IOR INSIDE-WID INSIDE-HEI *GRAY1* 0 0 0 0)))))
  952.  
  953.  
  954.  
  955. ;;;redisplay for graphics boxes
  956.  
  957. (DEFMETHOD (GRAPHICS-SCREEN-BOX :REDISPLAY-INFERIORS-PASS-1) (INFS-NEW-MAX-WID
  958.                                    INFS-NEW-MAX-HEI
  959.                                    &OPTIONAL
  960.                                    (FIRST-INF-X-OFFSET 0)
  961.                                    (FIRST-INF-Y-OFFSET 0)
  962.                                    IGNORE)
  963.   (LET* ((GRAPHICS-SHEET (TELL ACTUAL-OBJ :GRAPHICS-SHEET))
  964.      (DESIRED-WID (GRAPHICS-SHEET-DRAW-WID GRAPHICS-SHEET))
  965.      (DESIRED-HEI (GRAPHICS-SHEET-DRAW-HEI GRAPHICS-SHEET)))
  966.     ;; first make-sure that there is a screen object for the graphics sheet
  967.     
  968.     (WHEN (NULL (TELL SELF :SCREEN-SHEET))
  969.       (TELL SELF :SET-SCREEN-SHEET (ALLOCATE-SCREEN-SHEET-FOR-USE-IN GRAPHICS-SHEET SELF))
  970.       ;; now adjust the offsets of the graphics-screen-sheet
  971.       (LET ((SCREEN-SHEET (TELL SELF :SCREEN-SHEET)))
  972.     (UNLESS (= FIRST-INF-X-OFFSET (GRAPHICS-SCREEN-SHEET-X-OFFSET SCREEN-SHEET))
  973.       (SET-GRAPHICS-SCREEN-SHEET-X-OFFSET SCREEN-SHEET FIRST-INF-X-OFFSET))
  974.     (UNLESS (= FIRST-INF-Y-OFFSET (GRAPHICS-SCREEN-SHEET-Y-OFFSET SCREEN-SHEET))
  975.       (SET-GRAPHICS-SCREEN-SHEET-Y-OFFSET SCREEN-SHEET FIRST-INF-Y-OFFSET))))
  976.     ;; error check, remove this SOON !!!!!!!
  977.     (IF (NOT (GRAPHICS-SCREEN-SHEET? SCREEN-ROWS))
  978.     (FERROR "The object ~S, inside of ~S is not a GRAPHICS-SHEET. " SCREEN-ROWS SELF)
  979.     
  980.     
  981.     (VALUES (MIN DESIRED-WID INFS-NEW-MAX-WID)    ;width of the innards
  982.         ;; either there is enough room for the entire bit-array to
  983.         ;; be displayed or else we return whatever room we are given
  984.         (MIN DESIRED-HEI INFS-NEW-MAX-HEI)    ;height of the innards
  985.         ;; same argument as above
  986.         (> DESIRED-WID INFS-NEW-MAX-WID)    ;x-got-clipped?
  987.         (> DESIRED-HEI INFS-NEW-MAX-HEI)))))    ;y-got-clipped?
  988.  
  989. (DEFMETHOD (GRAPHICS-SCREEN-BOX :REDISPLAY-INFERIORS-PASS-2) ()
  990.   (LET ((*COMPLETE-REDISPLAY-IN-PROGRESS?*
  991.       (OR *COMPLETE-REDISPLAY-IN-PROGRESS?* FORCE-REDISPLAY-INFS?))
  992.     (GRAPHICS-SHEET (GRAPHICS-SCREEN-SHEET-ACTUAL-OBJ (TELL SELF :SCREEN-SHEET))))
  993.     (MULTIPLE-VALUE-BIND (X Y)
  994.     (GRAPHICS-SCREEN-SHEET-OFFSETS (TELL SELF :SCREEN-SHEET))
  995.     (MULTIPLE-VALUE-BIND (WIDTH HEIGHT)
  996.     (TELL ACTUAL-OBJ :GRAPHICS-SHEET-SIZE)
  997.       (BITBLT-TO-SCREEN TV:ALU-SETA WIDTH HEIGHT (GRAPHICS-SHEET-BIT-ARRAY GRAPHICS-SHEET)
  998.             0 0 X Y)))))
  999.  
  1000.  
  1001.  
  1002. (DEFUN REDISPLAY-WINDOW (&OPTIONAL (WINDOW *BOXER-PANE*))
  1003.   (REDISPLAYING-WINDOW (WINDOW)
  1004.     (LET ((*COMPLETE-REDISPLAY-IN-PROGRESS?* (OR *COMPLETE-REDISPLAY-IN-PROGRESS?*
  1005.                   (ASSQ ':CLEAR-SCREEN *REDISPLAY-CLUES*))))
  1006.       (COND ((NOT-NULL *COMPLETE-REDISPLAY-IN-PROGRESS?*)
  1007.          (TELL WINDOW #-SYMBOLICS :CLEAR-SCREEN #+SYMBOLICS :CLEAR-WINDOW)))
  1008.       (REDISPLAY-PASS-1)
  1009.       (REDISPLAY-PASS-2))))
  1010.  
  1011. (DEFUN REDISPLAY ()
  1012.   (DOLIST (REDISPLAYABLE-WINDOW *REDISPLAYABLE-WINDOWS*)
  1013.     (REDISPLAY-WINDOW REDISPLAYABLE-WINDOW))
  1014.   (DOLIST (REGION REGION-LIST)
  1015.     (TELL-CHECK-NIL REGION :UPDATE-REDISPLAY-ALL-ROWS))
  1016.   (SETQ *REDISPLAY-CLUES* NIL)
  1017.   (REDISPLAY-CURSOR))
  1018.  
  1019. (DEFUN FORCE-REDISPLAY ()
  1020.   (LET ((*COMPLETE-REDISPLAY-IN-PROGRESS?* T))
  1021.     (REDISPLAY)))
  1022.  
  1023. (DEFUN FORCE-REDISPLAY-WINDOW (&OPTIONAL (WINDOW *BOXER-PANE*))
  1024.   (LET ((*COMPLETE-REDISPLAY-IN-PROGRESS?* T))
  1025.     (REDISPLAY-WINDOW WINDOW)))
  1026.  
  1027. (DEFUN REDISPLAY-CURSOR (&OPTIONAL (CURSOR *POINT*))
  1028.   (WITH-FONT-MAP-BOUND (*BOXER-PANE*)
  1029.     (AND (BP? CURSOR)
  1030.      (LET ((POSITIONS (BP-POSITIONS CURSOR))
  1031.            (CHA (BP-CHA *POINT*)))
  1032.        (WHEN POSITIONS
  1033.          (TELL *BOXER-PANE* :SET-CURSORPOS (CAR POSITIONS) (CDR POSITIONS))
  1034.          (TELL *POINT-BLINKER* :SET-SIZE 3 (get-cursor-height cha)))))))
  1035.  
  1036. (defun get-cursor-height (cha)
  1037.   (COND ((NULL CHA) 12)
  1038.     ((CHA? CHA) (CHA-HEI (FONT-NO CHA)))
  1039.     ((and (box? cha) (null (tell cha :displayed-screen-objs)))
  1040.      17)
  1041.     ((EQ ':SHRUNK
  1042.          (TELL (BP-SCREEN-BOX *POINT*)
  1043.            :DISPLAY-STYLE))
  1044.      (- (SCREEN-OBJ-HEI (BP-SCREEN-BOX *POINT*))
  1045.         17))
  1046.     ((name-row? (tell cha :name-row))
  1047.      (multiple-value-bind (ignore hei)
  1048.          (screen-box-borders-fn ':tab-size (car (tell cha :displayed-screen-objs)))
  1049.        (+ hei 7)))
  1050.     (T
  1051.        (let ((sb (INF-CURRENT-SCREEN-BOX CHA)))
  1052.          (if (null sb) 17      (SCREEN-OBJ-HEI sb))))))
  1053.  
  1054.  
  1055.  
  1056. (DEFUN REDISPLAY-PASS-1 ()
  1057.   (MULTIPLE-VALUE-BIND (MAX-WID MAX-HEI)
  1058.       (OUTERMOST-SCREEN-BOX-SIZE *REDISPLAY-WINDOW*)
  1059.     (COND ((NULL *OUTERMOST-SCREEN-BOX*))
  1060.       ((TELL *OUTERMOST-SCREEN-BOX* :NEEDS-REDISPLAY-PASS-1? MAX-WID MAX-HEI)
  1061.        (TELL *OUTERMOST-SCREEN-BOX* :REDISPLAY-PASS-1 MAX-WID MAX-HEI)))))
  1062.  
  1063. (DEFUN REDISPLAY-PASS-2 ()
  1064.   (WHEN (TELL *OUTERMOST-SCREEN-BOX* :NEEDS-REDISPLAY-PASS-2?)
  1065.     (TELL *OUTERMOST-SCREEN-BOX* :REDISPLAY-PASS-2)))
  1066.  
  1067. (DEFUN REDISPLAY-SCREEN-BOX (SCREEN-BOX)
  1068.   (REDISPLAYING-BOX SCREEN-BOX
  1069.     (COND ((NOT-NULL *COMPLETE-REDISPLAY-IN-PROGRESS?*)
  1070.        (ERASE-SCREEN-OBJ SCREEN-BOX)))
  1071.     (MULTIPLE-VALUE-BIND (MAX-WID MAX-HEI)
  1072.     (SCREEN-OBJ-SIZE SCREEN-BOX)
  1073.       (COND ((NULL SCREEN-BOX))
  1074.         ((TELL SCREEN-BOX :NEEDS-REDISPLAY-PASS-1? MAX-WID MAX-HEI)
  1075.          (TELL SCREEN-BOX :REDISPLAY-PASS-1 MAX-WID MAX-HEI))))
  1076.     (WHEN (TELL SCREEN-BOX :NEEDS-REDISPLAY-PASS-2?)
  1077.       (TELL SCREEN-BOX :REDISPLAY-PASS-2))))
  1078.  
  1079. (DEFUN REDISPLAY-BOX (BOX)            ;this is the right thing to call on fixed size
  1080.   (DOLIST (SCREEN-BOX (TELL BOX :DISPLAYED-SCREEN-OBJS))    ;actual boxes
  1081.     (REDISPLAY-SCREEN-BOX SCREEN-BOX)))
  1082.